home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlspedit.arc / EDIT.LSP next >
Encoding:
Lisp/Scheme  |  1980-01-04  |  9.4 KB  |  371 lines
  1. ;
  2. ;                      The XLISP EDITOR V1.1
  3. ;                                by
  4. ;                          R.C. Philbrick
  5. ;
  6. ; For use with Xlisp V2.0.T5 on the Atari ST.
  7. ;
  8. ; To edit a function: (ef '<function-name>)
  9. ; To edit a list: (edit '<list-name>)
  10. ; To save a function (function must be executed outside the editor):
  11. ;    (sve '(<function-names>))
  12. ;    where <function-names> is a series of function names separated
  13. ;    by spaces.
  14. ;
  15. ; To use with Xlisp V1.7 simply delete the "ef" function,
  16. ; use (edit '<function-name>), and provide a pretty-print program.
  17. ; The main pretty-print procedure should be named "pprint".
  18. ;
  19. ; If you prefer to have prompts active in the editor program,
  20. ; just remove the semicolons in the appropriate places in the listing.
  21. ;
  22. ;
  23. ; Sorry, the editor doesn't work completely right on IBMs... yet.
  24. ;
  25. ;
  26. ; Send questions, suggestions, bug reports (about the editor), etc.
  27. ; to one of the following addresses:
  28. ;
  29. ; Bitnet address:               Home address: 204 Orchard Circle
  30. ; IO60260 at MAINE.BITNET                     Hamilton, Va. 22068
  31. ;
  32. ; Campus address:
  33. ; 103 Gannett Hall
  34. ; Univ. of Maine
  35. ; Orono, Me. 04469
  36. ;
  37. ;
  38. ;
  39. ; Command Summary:
  40. ;
  41. ;   ex - Exits the editor.
  42. ; cmds - Returns the current command set.
  43. ;    a - Advance through the current list.
  44. ;    b - Back up through the list.
  45. ;    d - descend into a sublist.
  46. ;  top - Moves back to the top.
  47. ;  bot - Moves to the bottom of the.
  48. ;  del - Deletes the current element.
  49. ;  rmp - Remove one level of parentheses from the current element.
  50. ;  enp - Enclose the current element in one level of parentheses.
  51. ;    g - Group the current element to following elements.
  52. ;   pp - pretty-print the entire expression being edited.
  53. ;
  54. ; The following commands expect parameters to be supplied:
  55. ;
  56. ;   goto <n> - Finds the point in the current sublist that equates to
  57. ;              <n> and makes it the current element.
  58. ;      r <n> - Replaces the current element with <n>.
  59. ; xcg <a><b> - Exchanges all occurrences of <a> with <b>.
  60. ;      i <n> - Inserts <n> behind the current element.
  61. ;   mv <cmd> - mv c "Move function: Cut" Saves the current element
  62. ;                   to the variable "sxpr" and deletes it from the
  63. ;                   current sublist.
  64. ;              mv p "Move function: Paste" Inserts the contents of the
  65. ;                   just behind the current element.
  66. ;   pre <n> - "Prefix" creates a list whose members are <n> followed
  67. ;             by the current element.
  68. ;
  69. ;
  70. ; And now... Here's the program!
  71. ;
  72. (defun edit (s-exp)
  73. (prog nil
  74. (gc)
  75. (setq comset '(ex cmds a b d top bot goto r xcg i mv pre del rmp enp g pp))
  76. top
  77. (terpri)
  78. (setq base s-exp)
  79. (setq curloc s-exp)
  80. loop
  81. (pprint (eval curloc))
  82. (terpri)
  83. (princ '"Edit:  ")
  84. (setq cmd (read))
  85. (cond ((equal cmd 'ex)
  86.        (setq curloc base)
  87.        (gc)
  88.        (princ "exited")
  89.        (terpri)
  90.        (terpri)
  91.        (return))
  92.       ((equal cmd 'top)
  93.        (setq curloc base))
  94.       ((equal cmd 'cmds)
  95.        (print comset)
  96.        (terpri))
  97.       ((member cmd comset)
  98.        (funcall cmd curloc))
  99.       (t (prin1 cmd)
  100.          (princ '" is not in the command set.")
  101.          (terpri)))
  102. (go loop)))
  103. ;
  104. ;
  105. ; advance
  106. (defun a (x)
  107. (cond ((atom x)
  108.        (setq x (list 'car x)))
  109.       (t (setq x (list 'car (list 'cdr (cadr x))))))
  110. (cond ((equal (length (eval (cadr x))) 0)
  111.        (princ '"End of s-expression.")
  112.        (terpri)
  113.        curloc)
  114.       (t (setq curloc x))))
  115. ;
  116. ;
  117. ; backup
  118. (defun b (x)
  119. (cond ((atom x)
  120.        (princ '"At top level.")
  121.        (terpri)
  122.        x)
  123.       ((atom (cadr x))
  124.        (setq x (cadr x)))
  125.       (t (setq x (rplacd x (cdadr x)))))
  126. (setq curloc x))
  127. ;
  128. ;
  129. ; descend
  130. (defun d (x)
  131. (cond ((atom (eval x))
  132.        (princ '"S-expression is atomic.")
  133.        (terpri)
  134.        x)
  135.       (t (setq x (list 'car x))))
  136. (setq curloc x))
  137. ;
  138. ;
  139. ; advance to end (used by bot)
  140. (defun ae (x)
  141. (cond ((atom (eval x))
  142.        x)
  143.       ((equal (length (eval x)) 1)
  144.        (ae (list 'car x)))
  145.       (t (ae (list 'cdr x)))))
  146. ;
  147. ;
  148. ; go to a point in the list that starts with the same s-expression
  149. (defun goto (x)
  150. (setq tmp2 x)
  151. ;(princ "Go to --")                     ;You want prompts?  We got prompts.
  152. (find (read) x)
  153. (setq x tmp2)
  154. (setq curloc x))
  155. ;
  156. ;
  157. ; used by goto
  158. (defun find (tmp x)
  159. (cond ((equal tmp (eval x)) (setq tmp2 x))
  160. ((atom (eval x)) x)
  161. (t (find tmp (list (quote cdr) x))
  162.  (find tmp (list (quote car) x)))))
  163. ;
  164. ;
  165. ; go to the bottom of the current list
  166. (defun bot (x)
  167. (setq x (ae x))
  168. (setq curloc x))
  169. ;
  170. ;
  171. ; replace
  172. (defun r (x)
  173. ;(princ "Enter new expression --")      ;You want prompts?  We got prompts.
  174. (rplaca (eval (cadr x)) (read))
  175. (setq curloc x))
  176. ;
  177. ;
  178. ; exchange all occurrences of x with y
  179. (defun xcg (x)
  180. ;(princ "Exchange --")                  ;You want prompts?  We got prompts.
  181. (switch (read) (read) x)
  182. (setq curloc x))
  183. ;
  184. ;
  185. ; used by xcg
  186. (defun switch (tmp tmp2 x)
  187. (cond ((equal tmp (eval x))
  188.        (rplaca (eval (cadr x)) tmp2))
  189.       ((atom (eval x)) x)
  190.       (t (switch tmp tmp2 (list (quote cdr) x))
  191.          (switch tmp tmp2 (list (quote car) x)))))
  192. ;
  193. ;
  194. ; insert
  195. (defun i (x)
  196. ;(princ "Enter insertion --")           ;You want prompts?  We got prompts.
  197. (setq tmp (cons (read) (cdr (eval (cadr x)))))
  198. (rplacd (eval (cadr x)) tmp)
  199. (setq x (a x))
  200. (setq curloc x))
  201. ;
  202. ;
  203. ; prefix
  204. (defun pre (x)
  205. ;(princ "Enter prefix --")              ;You want prompts?  We got prompts.
  206. (rplaca (eval (cadr x)) (list (read) (eval x)))
  207. (setq curloc x))
  208. ;
  209. ;
  210. ; remove current element
  211. (defun del (x)
  212. (cond ((atom x) (set x (cdr (eval x))))
  213.       ((atom (cadr x))
  214.        (set (cadr x) (cdr (eval (cadr x)))))
  215.       ((equal (caadr x) 'car)
  216.        (rplaca (eval (cadadr x)) (cdr (eval (cadr x)))))
  217.       (t (rplacd (eval (cadadr x)) (cdr (eval (cadr x))))))
  218. (setq curloc x))
  219. ;
  220. ;
  221. ; move current element
  222. (defun mv (x)
  223. ;(princ "cut/paste (c/p) --")           ;You want prompts?  We got prompts.
  224. (cond ((equal (read) (quote c))
  225.        (setq sxpr (eval x))
  226.        (del x))
  227.       (t (setq sxpr (cons sxpr (cdr (eval (cadr x)))))
  228.        (rplacd (eval (cadr x)) sxpr)
  229.        (setq x (a x))))
  230. (setq curloc x))
  231. ;
  232. ;
  233. ; remove parentheses
  234. (defun rmp (x)
  235. (setq tmp (eval (cadr x)))
  236. (setq tmp (nconc (car tmp) (cdr tmp)))
  237. (rplaca (eval (cadr x)) (car tmp))
  238. (rplacd (eval (cadr x)) (cdr tmp))
  239. (setq curloc x))
  240. ;
  241. ;
  242. ; enclose in parentheses
  243. (defun enp (x)
  244. (rplaca (eval (cadr x)) (list (eval x)))
  245. (setq curloc x))
  246. ;
  247. ;
  248. ; group current element to trailing elements
  249. (defun g (x)
  250. (prog nil
  251. (cond ((atom x)
  252.        (princ "Not available at this level.")
  253.        (terpri)
  254.        (terpri)
  255.        (return)))
  256. (setq tmp (list (eval x)))
  257. (setq tmp2 (list (quote cdr) (cadr x)))
  258. loop
  259. (terpri)
  260. (pprint tmp)
  261. loop2
  262. (terpri)
  263. (princ "Continue? (y/n) --")
  264. (cond ((equal (read) (quote y))
  265.        (cond ((equal (length (eval tmp2)) 0)
  266.               (terpri)
  267.               (princ "At bottom level.")
  268.               (terpri)
  269.               (terpri)
  270.               (go loop2))
  271.              (t (setq tmp (nconc tmp
  272.                            (list (eval (list (quote car) tmp2)))))
  273.               (setq tmp2 (list (quote cdr) tmp2))
  274.               (go loop))))
  275.       (t (terpri)
  276.         (cond ((atom (cadr x))
  277.                (set (cadr x) (cons tmp (eval tmp2))))
  278.               ((equal (caadr x) (quote car))
  279.                (rplaca (eval (cadadr x)) (cons tmp (eval tmp2))))
  280.               (t (rplacd (eval (cadadr x))
  281.                  (cons tmp (eval tmp2))))))))
  282. (setq curloc x))
  283. ;
  284. ;
  285. ; pprint entire expression being edited
  286. (defun pp (x)
  287. (pprint (eval base))
  288. (princ "________________________________________")
  289. (terpri)
  290. (terpri))
  291. ;
  292. ;
  293. ; save a function or macro definition
  294. (defun sve (x)
  295. (prog nil
  296. (cond ((atom x)
  297.        (princ "No can do.  Must be a list.")
  298.        (terpri)
  299.        (return)))
  300. (princ "Enter filename --")
  301. (setq fnme (read))
  302. (setq fp (open fnme :direction :output))
  303. loop
  304. (cond ((not (fboundp (car x)))
  305.        (prin1 (car x))
  306.        (princ " -- is not a function.")
  307.        (terpri)
  308.        (go pop)))
  309. (setq bse (car x))
  310. (setq bse (symbol-function bse))
  311. (setq prms (cadar bse))
  312. (setq nmf (cadr (caddar bse)))
  313. (setq rst (cddr (caddar bse)))
  314. (cond ((equal (caar bse) (quote macro))
  315.        (setq tpe (quote defmacro)))
  316.       (t (setq tpe (quote defun))))
  317. (setq ttl (cons tpe (cons nmf (cons prms rst))))
  318. (pprint ttl fp)
  319. pop
  320. (cond ((equal (length (cdr x)) 0)
  321.        (close fp)
  322.        (return 'saved))
  323.       (t (terpri fp)
  324.        (setq x (cdr x))
  325.        (go loop)))))
  326. ;
  327. ;
  328. ; used to invoke the editor on function definitions
  329. (defun ef (x)
  330. (prog nil
  331. (setq sf x)
  332. (cond ((not (fboundp sf))
  333. (prin1 sf)
  334. (princ " -- is not a function.")
  335. (terpri)
  336. (return 'exited)))
  337. ; For Atari ST Xlisp V2.0.T5:
  338. (setq sf (symbol-function sf))
  339. ; For IBM Xlisp V2.0:
  340. ;(setq sf (list (get-lambda-expression (symbol-function sf))))
  341. (edit (quote sf))))
  342. ;
  343. ;
  344. ; --==<<** And now for some marginally useful function definitions **>>==--
  345. ;
  346. ;
  347. ; use to pretty-print functions
  348. (defun ppf (x)
  349. ; For Atari ST Xlisp V2.0.T5:
  350. (pprint (symbol-function x))
  351. ; For IBM Xlisp V2.0:
  352. ;(pprint (get-lambda-expression (symbol-function x)))
  353. )
  354. ;
  355. ;
  356. ; Because typing "(top-level)" that many times is a royal pain!
  357. (defun tl () (eval (top-level)))
  358. ;
  359. ;
  360. ; use to clear the screen
  361. (defun cls ()
  362. (prog nil
  363. (setq lp 24)
  364. loop
  365. (cond ((> lp 0)
  366.        (setq lp (- lp 1))
  367.        (terpri)
  368.        (go loop)))))
  369.  
  370.  
  371.